PC Open 107

home *** CD-ROM | disk | FTP | other *** search

/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / $_1_ / BerkeleyDB.pm < prev next >

Wrap

Perl POD Document | 2003-05-17 | 32.2 KB | 1,560 lines

package BerkeleyDB; # Copyright (c) 1997-2003 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # The documentation for this module is at the bottom of this file, # after the line __END__. BEGIN { require 5.004_04 } use strict; use Carp; use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $use_XSLoader); $VERSION = '0.22'; require Exporter; #require DynaLoader; require AutoLoader; BEGIN { $use_XSLoader = 1 ; { local $SIG{__DIE__} ; eval { require XSLoader } ; } if ($@) { $use_XSLoader = 0 ; require DynaLoader; @ISA = qw(DynaLoader); } } @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. # NOTE -- Do not add to @EXPORT directly. It is written by mkconsts @EXPORT = qw( DB_AFTER DB_AGGRESSIVE DB_ALREADY_ABORTED DB_APPEND DB_APPLY_LOGREG DB_APP_INIT DB_ARCH_ABS DB_ARCH_DATA DB_ARCH_LOG DB_AUTO_COMMIT DB_BEFORE DB_BROADCAST_EID DB_BTREE DB_BTREEMAGIC DB_BTREEOLDVER DB_BTREEVERSION DB_CACHED_COUNTS DB_CDB_ALLDB DB_CHECKPOINT DB_CHKSUM_SHA1 DB_CLIENT DB_CL_WRITER DB_COMMIT DB_CONSUME DB_CONSUME_WAIT DB_CREATE DB_CURLSN DB_CURRENT DB_CXX_NO_EXCEPTIONS DB_DELETED DB_DELIMITER DB_DIRECT DB_DIRECT_DB DB_DIRECT_LOG DB_DIRTY_READ DB_DONOTINDEX DB_DUP DB_DUPCURSOR DB_DUPSORT DB_EID_BROADCAST DB_EID_INVALID DB_ENCRYPT DB_ENCRYPT_AES DB_ENV_APPINIT DB_ENV_AUTO_COMMIT DB_ENV_CDB DB_ENV_CDB_ALLDB DB_ENV_CREATE DB_ENV_DBLOCAL DB_ENV_DIRECT_DB DB_ENV_DIRECT_LOG DB_ENV_FATAL DB_ENV_LOCKDOWN DB_ENV_LOCKING DB_ENV_LOGGING DB_ENV_NOLOCKING DB_ENV_NOMMAP DB_ENV_NOPANIC DB_ENV_OPEN_CALLED DB_ENV_OVERWRITE DB_ENV_PANIC_OK DB_ENV_PRIVATE DB_ENV_REGION_INIT DB_ENV_REP_CLIENT DB_ENV_REP_LOGSONLY DB_ENV_REP_MASTER DB_ENV_RPCCLIENT DB_ENV_RPCCLIENT_GIVEN DB_ENV_STANDALONE DB_ENV_SYSTEM_MEM DB_ENV_THREAD DB_ENV_TXN DB_ENV_TXN_NOSYNC DB_ENV_TXN_WRITE_NOSYNC DB_ENV_USER_ALLOC DB_ENV_YIELDCPU DB_EXCL DB_EXTENT DB_FAST_STAT DB_FCNTL_LOCKING DB_FILE_ID_LEN DB_FIRST DB_FIXEDLEN DB_FLUSH DB_FORCE DB_GETREC DB_GET_BOTH DB_GET_BOTHC DB_GET_BOTH_RANGE DB_GET_RECNO DB_HANDLE_LOCK DB_HASH DB_HASHMAGIC DB_HASHOLDVER DB_HASHVERSION DB_INCOMPLETE DB_INIT_CDB DB_INIT_LOCK DB_INIT_LOG DB_INIT_MPOOL DB_INIT_TXN DB_INVALID_EID DB_JAVA_CALLBACK DB_JOINENV DB_JOIN_ITEM DB_JOIN_NOSORT DB_KEYEMPTY DB_KEYEXIST DB_KEYFIRST DB_KEYLAST DB_LAST DB_LOCKDOWN DB_LOCKMAGIC DB_LOCKVERSION DB_LOCK_CONFLICT DB_LOCK_DEADLOCK DB_LOCK_DEFAULT DB_LOCK_DUMP DB_LOCK_EXPIRE DB_LOCK_FREE_LOCKER DB_LOCK_GET DB_LOCK_GET_TIMEOUT DB_LOCK_INHERIT DB_LOCK_MAXLOCKS DB_LOCK_MINLOCKS DB_LOCK_MINWRITE DB_LOCK_NORUN DB_LOCK_NOTEXIST DB_LOCK_NOTGRANTED DB_LOCK_NOTHELD DB_LOCK_NOWAIT DB_LOCK_OLDEST DB_LOCK_PUT DB_LOCK_PUT_ALL DB_LOCK_PUT_OBJ DB_LOCK_PUT_READ DB_LOCK_RANDOM DB_LOCK_RECORD DB_LOCK_REMOVE DB_LOCK_RIW_N DB_LOCK_RW_N DB_LOCK_SET_TIMEOUT DB_LOCK_SWITCH DB_LOCK_TIMEOUT DB_LOCK_TRADE DB_LOCK_UPGRADE DB_LOCK_UPGRADE_WRITE DB_LOCK_YOUNGEST DB_LOGC_BUF_SIZE DB_LOGFILEID_INVALID DB_LOGMAGIC DB_LOGOLDVER DB_LOGVERSION DB_LOG_DISK DB_LOG_LOCKED DB_LOG_SILENT_ERR DB_MAX_PAGES DB_MAX_RECORDS DB_MPOOL_CLEAN DB_MPOOL_CREATE DB_MPOOL_DIRTY DB_MPOOL_DISCARD DB_MPOOL_EXTENT DB_MPOOL_LAST DB_MPOOL_NEW DB_MPOOL_NEW_GROUP DB_MPOOL_PRIVATE DB_MULTIPLE DB_MULTIPLE_KEY DB_MUTEXDEBUG DB_MUTEXLOCKS DB_NEEDSPLIT DB_NEXT DB_NEXT_DUP DB_NEXT_NODUP DB_NOCOPY DB_NODUPDATA DB_NOLOCKING DB_NOMMAP DB_NOORDERCHK DB_NOOVERWRITE DB_NOPANIC DB_NORECURSE DB_NOSERVER DB_NOSERVER_HOME DB_NOSERVER_ID DB_NOSYNC DB_NOTFOUND DB_ODDFILESIZE DB_OK_BTREE DB_OK_HASH DB_OK_QUEUE DB_OK_RECNO DB_OLD_VERSION DB_OPEN_CALLED DB_OPFLAGS_MASK DB_ORDERCHKONLY DB_OVERWRITE DB_PAD DB_PAGEYIELD DB_PAGE_LOCK DB_PAGE_NOTFOUND DB_PANIC_ENVIRONMENT DB_PERMANENT DB_POSITION DB_POSITIONI DB_PREV DB_PREV_NODUP DB_PRINTABLE DB_PRIORITY_DEFAULT DB_PRIORITY_HIGH DB_PRIORITY_LOW DB_PRIORITY_VERY_HIGH DB_PRIORITY_VERY_LOW DB_PRIVATE DB_PR_HEADERS DB_PR_PAGE DB_PR_RECOVERYTEST DB_QAMMAGIC DB_QAMOLDVER DB_QAMVERSION DB_QUEUE DB_RDONLY DB_RDWRMASTER DB_RECNO DB_RECNUM DB_RECORDCOUNT DB_RECORD_LOCK DB_RECOVER DB_RECOVER_FATAL DB_REGION_ANON DB_REGION_INIT DB_REGION_MAGIC DB_REGION_NAME DB_REGISTERED DB_RENAMEMAGIC DB_RENUMBER DB_REP_CLIENT DB_REP_DUPMASTER DB_REP_HOLDELECTION DB_REP_LOGSONLY DB_REP_MASTER DB_REP_NEWMASTER DB_REP_NEWSITE DB_REP_OUTDATED DB_REP_PERMANENT DB_REP_UNAVAIL DB_REVSPLITOFF DB_RMW DB_RPC_SERVERPROG DB_RPC_SERVERVERS DB_RUNRECOVERY DB_SALVAGE DB_SECONDARY_BAD DB_SEQUENTIAL DB_SET DB_SET_LOCK_TIMEOUT DB_SET_RANGE DB_SET_RECNO DB_SET_TXN_NOW DB_SET_TXN_TIMEOUT DB_SNAPSHOT DB_STAT_CLEAR DB_SURPRISE_KID DB_SWAPBYTES DB_SYSTEM_MEM DB_TEMPORARY DB_TEST_ELECTINIT DB_TEST_ELECTSEND DB_TEST_ELECTVOTE1 DB_TEST_ELECTVOTE2 DB_TEST_ELECTWAIT1 DB_TEST_ELECTWAIT2 DB_TEST_POSTDESTROY DB_TEST_POSTEXTDELETE DB_TEST_POSTEXTOPEN DB_TEST_POSTEXTUNLINK DB_TEST_POSTLOG DB_TEST_POSTLOGMETA DB_TEST_POSTOPEN DB_TEST_POSTRENAME DB_TEST_POSTSYNC DB_TEST_PREDESTROY DB_TEST_PREEXTDELETE DB_TEST_PREEXTOPEN DB_TEST_PREEXTUNLINK DB_TEST_PREOPEN DB_TEST_PRERENAME DB_TEST_SUBDB_LOCKS DB_THREAD DB_TIMEOUT DB_TRUNCATE DB_TXNMAGIC DB_TXNVERSION DB_TXN_ABORT DB_TXN_APPLY DB_TXN_BACKWARD_ALLOC DB_TXN_BACKWARD_ROLL DB_TXN_CKP DB_TXN_FORWARD_ROLL DB_TXN_GETPGNOS DB_TXN_LOCK DB_TXN_LOCK_2PL DB_TXN_LOCK_MASK DB_TXN_LOCK_OPTIMIST DB_TXN_LOCK_OPTIMISTIC DB_TXN_LOG_MASK DB_TXN_LOG_REDO DB_TXN_LOG_UNDO DB_TXN_LOG_UNDOREDO DB_TXN_NOSYNC DB_TXN_NOWAIT DB_TXN_OPENFILES DB_TXN_POPENFILES DB_TXN_PRINT DB_TXN_REDO DB_TXN_SYNC DB_TXN_UNDO DB_TXN_WRITE_NOSYNC DB_UNKNOWN DB_UNRESOLVED_CHILD DB_UPDATE_SECONDARY DB_UPGRADE DB_USE_ENVIRON DB_USE_ENVIRON_ROOT DB_VERB_CHKPOINT DB_VERB_DEADLOCK DB_VERB_RECOVERY DB_VERB_REPLICATION DB_VERB_WAITSFOR DB_VERIFY DB_VERIFY_BAD DB_VERIFY_FATAL DB_VERSION_MAJOR DB_VERSION_MINOR DB_VERSION_PATCH DB_VERSION_STRING DB_VRFY_FLAGMASK DB_WRITECURSOR DB_WRITELOCK DB_WRITEOPEN DB_WRNOSYNC DB_XA_CREATE DB_XIDDATASIZE DB_YIELDCPU ); sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; my ($error, $val) = constant($constname); Carp::croak $error if $error; no strict 'refs'; *{$AUTOLOAD} = sub { $val }; goto &{$AUTOLOAD}; } #bootstrap BerkeleyDB $VERSION; if ($use_XSLoader) { XSLoader::load("BerkeleyDB", $VERSION)} else { bootstrap BerkeleyDB $VERSION } # Preloaded methods go here. sub ParseParameters($@) { my ($default, @rest) = @_ ; my (%got) = %$default ; my (@Bad) ; my ($key, $value) ; my $sub = (caller(1))[3] ; my %options = () ; local ($Carp::CarpLevel) = 1 ; # allow the options to be passed as a hash reference or # as the complete hash. if (@rest == 1) { croak "$sub: parameter is not a reference to a hash" if ref $rest[0] ne "HASH" ; %options = %{ $rest[0] } ; } elsif (@rest >= 2) { %options = @rest ; } while (($key, $value) = each %options) { $key =~ s/^-// ; if (exists $default->{$key}) { $got{$key} = $value } else { push (@Bad, $key) } } if (@Bad) { my ($bad) = join(", ", @Bad) ; croak "unknown key value(s) @Bad" ; } return \%got ; } sub parseEncrypt { my $got = shift ; if (defined $got->{Encrypt}) { croak("Encrypt parameter must be a hash reference") if !ref $got->{Encrypt} || ref $got->{Encrypt} ne 'HASH' ; my %config = %{ $got->{Encrypt} } ; my $p = BerkeleyDB::ParseParameters({ Password => undef, Flags => undef, }, %config); croak("Must specify Password and Flags with Encrypt parameter") if ! (defined $p->{Password} && defined $p->{Flags}); $got->{"Enc_Passwd"} = $p->{Password}; $got->{"Enc_Flags"} = $p->{Flags}; } } use UNIVERSAL qw( isa ) ; sub env_remove { # Usage: # # $env = new BerkeleyDB::Env # [ -Home => $path, ] # [ -Config => { name => value, name => value } # [ -Flags => DB_INIT_LOCK| ] # ; my $got = BerkeleyDB::ParseParameters({ Home => undef, Flags => 0, Config => undef, }, @_) ; if (defined $got->{Config}) { croak("Config parameter must be a hash reference") if ! ref $got->{Config} eq 'HASH' ; @BerkeleyDB::a = () ; my $k = "" ; my $v = "" ; while (($k, $v) = each %{$got->{Config}}) { push @BerkeleyDB::a, "$k\t$v" ; } $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) if @BerkeleyDB::a ; } return _env_remove($got) ; } sub db_remove { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Flags => 0, Env => undef, }, @_) ; croak("Must specify a filename") if ! defined $got->{Filename} ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); return _db_remove($got); } sub db_rename { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Newname => undef, Flags => 0, Env => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Must specify a filename") if ! defined $got->{Filename} ; croak("Must specify a Subname") if ! defined $got->{Subname} ; croak("Must specify a Newname") if ! defined $got->{Newname} ; return _db_rename($got); } sub db_verify { my $got = BerkeleyDB::ParseParameters( { Filename => undef, Subname => undef, Outfile => undef, Flags => 0, Env => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Must specify a filename") if ! defined $got->{Filename} ; return _db_verify($got); } package BerkeleyDB::Env ; use UNIVERSAL qw( isa ) ; use Carp ; use vars qw( %valid_config_keys ) ; sub isaFilehandle { my $fh = shift ; return ((isa($fh,'GLOB') or isa(\$fh,'GLOB')) and defined fileno($fh) ) } %valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR DB_TMP_DIR ) ; sub new { # Usage: # # $env = new BerkeleyDB::Env # [ -Home => $path, ] # [ -Mode => mode, ] # [ -Config => { name => value, name => value } # [ -ErrFile => filename, ] # [ -ErrPrefix => "string", ] # [ -Flags => DB_INIT_LOCK| ] # [ -Set_Flags => $flags,] # [ -Cachesize => number ] # [ -LockDetect => ] # [ -Verbose => boolean ] # [ -Encrypt => { Password => string, Flags => value} # # ; my $pkg = shift ; my $got = BerkeleyDB::ParseParameters({ Home => undef, Server => undef, Mode => 0666, ErrFile => undef, ErrPrefix => undef, Flags => 0, SetFlags => 0, Cachesize => 0, LockDetect => 0, Verbose => 0, Config => undef, Encrypt => undef, }, @_) ; if (defined $got->{ErrFile}) { croak("ErrFile parameter must be a file name") if ref $got->{ErrFile} ; #if (!isaFilehandle($got->{ErrFile})) { # my $handle = new IO::File ">$got->{ErrFile}" # or croak "Cannot open file $got->{ErrFile}: $!\n" ; # $got->{ErrFile} = $handle ; # } } my %config ; if (defined $got->{Config}) { croak("Config parameter must be a hash reference") if ! ref $got->{Config} eq 'HASH' ; %config = %{ $got->{Config} } ; @BerkeleyDB::a = () ; my $k = "" ; my $v = "" ; while (($k, $v) = each %config) { if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){ $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; croak $BerkeleyDB::Error ; } push @BerkeleyDB::a, "$k\t$v" ; } $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) if @BerkeleyDB::a ; } BerkeleyDB::parseEncrypt($got); my ($addr) = _db_appinit($pkg, $got) ; my $obj ; $obj = bless [$addr] , $pkg if $addr ; if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) { my ($k, $v); while (($k, $v) = each %config) { if ($k eq 'DB_DATA_DIR') { $obj->set_data_dir($v) } elsif ($k eq 'DB_LOG_DIR') { $obj->set_lg_dir($v) } elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR') { $obj->set_tmp_dir($v) } else { $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; croak $BerkeleyDB::Error } } } return $obj ; } sub TxnMgr { my $env = shift ; my ($addr) = $env->_TxnMgr() ; my $obj ; $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ; return $obj ; } sub txn_begin { my $env = shift ; my ($addr) = $env->_txn_begin(@_) ; my $obj ; $obj = bless [$addr, $env] , "BerkeleyDB::Txn" if $addr ; return $obj ; } sub DESTROY { my $self = shift ; $self->_DESTROY() ; } package BerkeleyDB::Hash ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; use UNIVERSAL qw( isa ) ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Hash specific Ffactor => 0, Nelem => 0, Hash => undef, DupCompare => undef, # BerkeleyDB specific ReadKey => undef, WriteKey => undef, ReadValue => undef, WriteValue => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; BerkeleyDB::parseEncrypt($got); my ($addr) = _db_open_hash($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *TIEHASH = \&new ; package BerkeleyDB::Btree ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ; use UNIVERSAL qw( isa ) ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Btree specific Minkey => 0, Compare => undef, DupCompare => undef, Prefix => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; BerkeleyDB::parseEncrypt($got); my ($addr) = _db_open_btree($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ; package BerkeleyDB::Recno ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL qw( isa ) ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Recno specific Delim => undef, Len => undef, Pad => undef, Source => undef, ArrayBase => 1, # lowest index in array }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); croak("Tie needs a reference to an array") if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; BerkeleyDB::parseEncrypt($got); $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; my ($addr) = _db_open_recno($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ; *BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ; package BerkeleyDB::Queue ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL qw( isa ) ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, # Queue specific Len => undef, Pad => undef, ArrayBase => 1, # lowest index in array ExtentSize => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); croak("Tie needs a reference to an array") if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}") if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ; BerkeleyDB::parseEncrypt($got); $got->{Fname} = $got->{Filename} if defined $got->{Filename} ; my ($addr) = _db_open_queue($self, $got); my $obj ; if ($addr) { $obj = bless [$addr] , $self ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } *BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ; sub UNSHIFT { my $self = shift; croak "unshift is unsupported with Queue databases"; } ## package BerkeleyDB::Text ; ## ## use vars qw(@ISA) ; ## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; ## use UNIVERSAL qw( isa ) ; ## use Carp ; ## ## sub new ## { ## my $self = shift ; ## my $got = BerkeleyDB::ParseParameters( ## { ## # Generic Stuff ## Filename => undef, ## #Flags => BerkeleyDB::DB_CREATE(), ## Flags => 0, ## Property => 0, ## Mode => 0666, ## Cachesize => 0, ## Lorder => 0, ## Pagesize => 0, ## Env => undef, ## #Tie => undef, ## Txn => undef, ## ## # Recno specific ## Delim => undef, ## Len => undef, ## Pad => undef, ## Btree => undef, ## }, @_) ; ## ## croak("Env not of type BerkeleyDB::Env") ## if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); ## ## croak("Txn not of type BerkeleyDB::Txn") ## if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); ## ## croak("-Tie needs a reference to an array") ## if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ; ## ## # rearange for recno ## $got->{Source} = $got->{Filename} if defined $got->{Filename} ; ## delete $got->{Filename} ; ## $got->{Fname} = $got->{Btree} if defined $got->{Btree} ; ## return BerkeleyDB::Recno::_db_open_recno($self, $got); ## } ## ## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ; ## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ; package BerkeleyDB::Unknown ; use vars qw(@ISA) ; @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ; use UNIVERSAL qw( isa ) ; use Carp ; sub new { my $self = shift ; my $got = BerkeleyDB::ParseParameters( { # Generic Stuff Filename => undef, Subname => undef, #Flags => BerkeleyDB::DB_CREATE(), Flags => 0, Property => 0, Mode => 0666, Cachesize => 0, Lorder => 0, Pagesize => 0, Env => undef, #Tie => undef, Txn => undef, Encrypt => undef, }, @_) ; croak("Env not of type BerkeleyDB::Env") if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env'); croak("Txn not of type BerkeleyDB::Txn") if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn'); croak("-Tie needs a reference to a hash") if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ; BerkeleyDB::parseEncrypt($got); my ($addr, $type) = _db_open_unknown($got); my $obj ; if ($addr) { $obj = bless [$addr], "BerkeleyDB::$type" ; push @{ $obj }, $got->{Env} if $got->{Env} ; $obj->Txn($got->{Txn}) if $got->{Txn} ; } return $obj ; } package BerkeleyDB::_tiedHash ; use Carp ; #sub TIEHASH #{ # my $self = shift ; # my $db_object = shift ; # #print "Tiehash REF=[$self] [" . (ref $self) . "]\n" ; # # return bless { Obj => $db_object}, $self ; #} sub Tie { # Usage: # # $db->Tie \%hash ; # my $self = shift ; #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; croak("usage \$x->Tie \\%hash\n") unless @_ ; my $ref = shift ; croak("Tie needs a reference to a hash") if defined $ref and $ref !~ /HASH/ ; #tie %{ $ref }, ref($self), $self ; tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ; return undef ; } sub TIEHASH { my $self = shift ; my $db_object = shift ; #return bless $db_object, 'BerkeleyDB::Common' ; return $db_object ; } sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->db_put($key, $value) ; } sub FETCH { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) ; return $value ; } sub EXISTS { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) == 0 ; } sub DELETE { my $self = shift ; my $key = shift ; $self->db_del($key) ; } sub CLEAR { my $self = shift ; my ($key, $value) = (0, 0) ; my $cursor = $self->_db_write_cursor() ; while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0) { $cursor->c_del() } } #sub DESTROY #{ # my $self = shift ; # print "BerkeleyDB::_tieHash::DESTROY\n" ; # $self->{Cursor}->c_close() if $self->{Cursor} ; #} package BerkeleyDB::_tiedArray ; use Carp ; sub Tie { # Usage: # # $db->Tie \@array ; # my $self = shift ; #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ; croak("usage \$x->Tie \\%hash\n") unless @_ ; my $ref = shift ; croak("Tie needs a reference to an array") if defined $ref and $ref !~ /ARRAY/ ; #tie %{ $ref }, ref($self), $self ; tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ; return undef ; } #sub TIEARRAY #{ # my $self = shift ; # my $db_object = shift ; # #print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ; # # return bless { Obj => $db_object}, $self ; #} sub TIEARRAY { my $self = shift ; my $db_object = shift ; #return bless $db_object, 'BerkeleyDB::Common' ; return $db_object ; } sub STORE { my $self = shift ; my $key = shift ; my $value = shift ; $self->db_put($key, $value) ; } sub FETCH { my $self = shift ; my $key = shift ; my $value = undef ; $self->db_get($key, $value) ; return $value ; } *CLEAR = \&BerkeleyDB::_tiedHash::CLEAR ; *FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ; *NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ; sub EXTEND {} # don't do anything with EXTEND sub SHIFT { my $self = shift; my ($key, $value) = (0, 0) ; my $cursor = $self->db_cursor() ; return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ; return undef if $cursor->c_del() != 0 ; return $value ; } sub UNSHIFT { my $self = shift; if (@_) { my ($key, $value) = (0, 0) ; my $cursor = $self->db_cursor() ; my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ; if ($status == 0) { foreach $value (reverse @_) { $key = 0 ; $cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ; } } elsif ($status == BerkeleyDB::DB_NOTFOUND()) { $key = 0 ; foreach $value (@_) { $self->db_put($key++, $value) ; } } } } sub PUSH { my $self = shift; if (@_) { my ($key, $value) = (-1, 0) ; my $cursor = $self->db_cursor() ; my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ; if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND()) { $key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ; foreach $value (@_) { ++ $key ; $status = $self->db_put($key, $value) ; } } # can use this when DB_APPEND is fixed. # foreach $value (@_) # { # my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ; #print "[$status]\n" ; # } } } sub POP { my $self = shift; my ($key, $value) = (0, 0) ; my $cursor = $self->db_cursor() ; return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ; return undef if $cursor->c_del() != 0 ; return $value ; } sub SPLICE { my $self = shift; croak "SPLICE is not implemented yet" ; } *shift = \&SHIFT ; *unshift = \&UNSHIFT ; *push = \&PUSH ; *pop = \&POP ; *clear = \&CLEAR ; *length = \&FETCHSIZE ; sub STORESIZE { croak "STORESIZE is not implemented yet" ; #print "STORESIZE @_\n" ; # my $self = shift; # my $length = shift ; # my $current_length = $self->FETCHSIZE() ; #print "length is $current_length\n"; # # if ($length < $current_length) { #print "Make smaller $length < $current_length\n" ; # my $key ; # for ($key = $current_length - 1 ; $key >= $length ; -- $key) # { $self->db_del($key) } # } # elsif ($length > $current_length) { #print "Make larger $length > $current_length\n" ; # $self->db_put($length-1, "") ; # } # else { print "stay the same\n" } } #sub DESTROY #{ # my $self = shift ; # print "BerkeleyDB::_tieArray::DESTROY\n" ; #} package BerkeleyDB::Common ; use Carp ; sub DESTROY { my $self = shift ; $self->_DESTROY() ; } sub Txn { my $self = shift ; my $txn = shift ; #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ; if ($txn) { $self->_Txn($txn) ; push @{ $txn }, $self ; } else { $self->_Txn() ; } #print "end BerkeleyDB::Common::Txn \n"; } sub get_dup { croak "Usage: \$db->get_dup(key [,flag])\n" unless @_ == 2 or @_ == 3 ; my $db = shift ; my $key = shift ; my $flag = shift ; my $value = 0 ; my $origkey = $key ; my $wantarray = wantarray ; my %values = () ; my @values = () ; my $counter = 0 ; my $status = 0 ; my $cursor = $db->db_cursor() ; # iterate through the database until either EOF ($status == 0) # or a different key is encountered ($key ne $origkey). for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ; $status == 0 and $key eq $origkey ; $status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) { # save the value or count number of matches if ($wantarray) { if ($flag) { ++ $values{$value} } else { push (@values, $value) } } else { ++ $counter } } return ($wantarray ? ($flag ? %values : @values) : $counter) ; } sub db_cursor { my $db = shift ; my ($addr) = $db->_db_cursor(@_) ; my $obj ; $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub _db_write_cursor { my $db = shift ; my ($addr) = $db->__db_write_cursor(@_) ; my $obj ; $obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub db_join { croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)' if @_ < 2 || @_ > 3 ; my $db = shift ; croak 'db_join: first parameter is not an array reference' if ! ref $_[0] || ref $_[0] ne 'ARRAY'; my ($addr) = $db->_db_join(@_) ; my $obj ; $obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } package BerkeleyDB::Cursor ; sub c_close { my $cursor = shift ; $cursor->[1] = "" ; return $cursor->_c_close() ; } sub c_dup { my $cursor = shift ; my ($addr) = $cursor->_c_dup(@_) ; my $obj ; $obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ; return $obj ; } sub DESTROY { my $self = shift ; $self->_DESTROY() ; } package BerkeleyDB::TxnMgr ; sub DESTROY { my $self = shift ; $self->_DESTROY() ; } sub txn_begin { my $txnmgr = shift ; my ($addr) = $txnmgr->_txn_begin(@_) ; my $obj ; $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ; return $obj ; } package BerkeleyDB::Txn ; sub Txn { my $self = shift ; my $db ; # keep a reference to each db in the txn object foreach $db (@_) { $db->_Txn($self) ; push @{ $self}, $db ; } } sub txn_commit { my $self = shift ; $self->disassociate() ; my $status = $self->_txn_commit() ; return $status ; } sub txn_abort { my $self = shift ; $self->disassociate() ; my $status = $self->_txn_abort() ; return $status ; } sub disassociate { my $self = shift ; my $db ; while ( @{ $self } > 2) { $db = pop @{ $self } ; $db->Txn() ; } #print "end disassociate\n" ; } sub DESTROY { my $self = shift ; $self->disassociate() ; # first close the close the transaction $self->_DESTROY() ; } package BerkeleyDB::Term ; END { close_everything() ; } package BerkeleyDB ; # Autoload methods go after =cut, and are processed by the autosplit program. 1; __END__